home *** CD-ROM | disk | FTP | other *** search
/ PC User 2002 July / Disc 1 / PCU0702CD1.iso / software / sfeflash / flies / en-us / ps_0 / regdb_email.cgi < prev    next >
Encoding:
Text File  |  2002-05-17  |  34.7 KB  |  1,198 lines
  1. #!/usr/local/bin/perl
  2.  
  3. use DBI;
  4. use CGI qw/:standard :escape :unescape/;
  5.  
  6. # $external_prefix is the prefix to append to lockssl-on.gif and thankyou_url if necessary.
  7. # If you want to use "/files/lockssl-on.gif" and "/files/thankyou.html" then $external_prefix
  8. # must be set to '/files/'
  9. $external_prefix = '';
  10.  
  11. $email_alert = 'support@3d3.com';                    # email in case of fatal error
  12. $back_url    = 'http://www.3d3.com/enter.html?target=Products.html';
  13. $mailusing   = 'sendmail';
  14. $mailprog    = '/bin/sendmail';
  15. $smtp_addr   = '127.0.0.1';
  16. $pgp_tmp     = "/tmp/pgporder.$$";
  17. $pgp_cmd     = '/usr/local/bin/pgpe';
  18. $pgp_opt     = '-fa +batchmode +force +NoBatchInvalidKeys=0';
  19.  
  20. $database = 'regdb';
  21. $user     = 'x3d3';
  22. $passwd   = '4dcubed';
  23.  
  24. # valid referers
  25. @referers = ('.*regdb_order\.cgi');
  26.  
  27. # required fields
  28. @required = ("order_email", "order_pairs");
  29.  
  30. &parse_form();
  31. &get_date();
  32. &check_referer()     or  &show_errors('bad_referer');
  33. (&check_required()   or  &show_errors('missing_fields', @ERROR)) if not @ERROR;
  34.  
  35. &decode_order($FORM{'order_pairs'});
  36. $is_upgrade = ($HEAD{'UPGRADECODE'} ? 1 : 0);
  37. $code       = $HEAD{'SHOPORDER'};
  38.  
  39. (&validate_code()    or  &show_errors('Invalid code', @ERROR)) if not @ERROR;
  40. (&process_order()    or  &send_error_email()) if not @ERROR;
  41. if($FORM{'redirect_only'} ne "true")
  42. {
  43.     &send_email();
  44.     &print_html();
  45. }
  46. else
  47. {
  48.     &redirect();
  49. }
  50.  
  51. sub process_order
  52. {
  53.     my $done = 0;
  54.     # connect to the database
  55.     $dbh = DBI->connect("DBI:mysql:$database", $user, $passwd);
  56.     if ($dbh)
  57.     {
  58.         # check if the code already exists
  59.         if (&check_code($dbh, $HEAD{'EXISTINGCODE'}))
  60.         {
  61.             # It does not exist , or it is being replaced.  Add it to the database.
  62.             if (&insert_items($dbh))
  63.             {
  64.                 # At this point, we have successfully inserted the items.
  65.                 # Now we need to insert the customer data.
  66.                 if (&insert_customer($dbh))
  67.                 {
  68.                     $done = 1;
  69.                 }
  70.             }
  71.         }
  72.         $dbh->disconnect;
  73.     }
  74.     else
  75.     {
  76.         &show_errors('\$dbh->connect() Failed', ('Unable to connect to database', $dbh->errstr));
  77.     }
  78.     return $done;
  79. }
  80.  
  81. sub validate_code
  82. {
  83.     my ($ok) = 0;
  84.     # check code for length = 12, all numbers or du-nnn-n+
  85.     if ( (not ($code =~ /^[0-9]{12}?$/)) &&
  86.          (not ($code =~ /^[a-z]{2}?-[0-9]{3}?-[0-9]+?$/)) )
  87.     {
  88.         push(@ERROR, "The code that came through with your order was corrupted");
  89.     }
  90.     else
  91.     {
  92.         $ok = 1;
  93.     }
  94.     return $ok;
  95. }
  96.  
  97. sub insert_items {
  98.     my($dbh) = @_;
  99.     my($ok) = 1;
  100.  
  101.     my ($customerName) = $dbh->quote($CUSTOMER{'NAME'});
  102.     my ($customerEmail) = $dbh->quote($CUSTOMER{'EMAIL'});
  103.  
  104.     foreach $key (keys %ITEM) {
  105.         # Here $key is the Item Number eg: "Pro4", or if an item is an upgrade,
  106.         # it is something like "Lite3-Pro4" where "Lite3" is the original item,
  107.         # and "Pro4" is the new item.
  108.  
  109.         my ($product, $version, $old_product, $old_version);
  110.  
  111.         my($item_upgrade) = 0;
  112.         my(@item_numbers) = split(/-/, $key);
  113.         if($#item_numbers == 1) {
  114.             # It's an upgrade
  115.  
  116.             ($old_product) = ($item_numbers[0] =~ /^(\w+)[0-9]+$/);
  117.             ($old_version) = ($item_numbers[0] =~ /^\w+([0-9]+)$/);
  118.             ($product) = ($item_numbers[1] =~ /^(\w+)[0-9]+$/);
  119.             ($version) = ($item_numbers[1] =~ /^\w+([0-9]+)$/);
  120.             $item_upgrade = 1;
  121.  
  122.         } elsif($#item_numbers >= 0) {
  123.             # It's a normal product
  124.  
  125.             ($product) = ($item_numbers[0] =~ /^(\w+)[0-9]+$/);
  126.             ($version) = ($item_numbers[0] =~ /^\w+([0-9]+)$/);
  127.  
  128.         } else {
  129.             # Something really weird happened...
  130.             die("split failed on $key");
  131.         }
  132.  
  133.         my($strupgrade, $strextra);
  134.         if($item_upgrade) {
  135.             $strupgrade = $dbh->quote("$old_product $old_version to $product $version");
  136.             $strextra = $dbh->quote("Original Code was $HEAD{'UPGRADECODE'}");
  137.         } else {
  138.             $strupgrade = "''";
  139.             $strextra = "''";
  140.         }
  141.  
  142.         my ($option);
  143.         if($ITEM{$key}{'OPTION'}) {
  144.             $option = $dbh->quote($ITEM{$key}{'OPTION'});
  145.         } else {
  146.             $option = "''";
  147.         }
  148.  
  149.         # Here we have $FORM{'reseller_id'}, which is either the ResellerID from
  150.         # the database (not Mid), or 'undefined'.
  151.         # We may also have HEAD{'CLICKTHROUGH'}.
  152.         # If $FORM{'reseller_id'} is valid, HEAD{'CLICKTHROUGH'} will be the
  153.         # Mid of that reseller.  We should not need to validate this.
  154.         # If $FORM{'reseller_id'} is not valid, and HEAD{'CLICKTHROUGH'} exists,
  155.         # it is an affiliate ID, and should be put in the Extra Info field.
  156.         # The ResellerID for that product should be set to "Affiliate".
  157.  
  158.         # Really, we should be ignoring $FORM{'reseller_id'} and have a function
  159.         # to determine the correct data to insert based on HEAD{'CLICKTHROUGH'}
  160.  
  161.         my($resellerId) = '0';
  162.         my($requestCust) = '0';
  163.  
  164.         # Request customer details if we don't have their street.
  165.         # We are checking street because we may already have their name and nothing
  166.         # else.
  167.         if(!$CUSTOMER{'STREET'} || $CUSTOMER{'STREET'} eq '') {
  168.             $requestCust = '1';
  169.         }
  170.  
  171.         if ($FORM{'clickthrough'} eq '0101')
  172.         {
  173.             $resellerId = ($FORM{'reseller_id'} or 0);
  174.             $strextra   = $dbh->quote('fc101');
  175.         }
  176.         elsif($FORM{'reseller_id'})
  177.         {
  178.             if($FORM{'reseller_id'} ne 'undefined') {
  179.                 $resellerId = ($FORM{'reseller_id'} or 0);
  180.                 $requestCust = '1';
  181.             }
  182.         }
  183.         elsif ($FORM{'clickthrough'})
  184.         {
  185.             $strextra = $dbh->quote('Affiliate');
  186.             my($sql) = qq[SELECT ResellerID from Reseller Where Mid = ].$dbh->quote($FORM{'clickthrough'});
  187.             my($sth) = $dbh->prepare($sql);
  188.             if($sth) {
  189.                 if($sth->execute) {
  190.                     if($sth->rows != 0) {
  191.                         $hashref    = $sth->fetchrow_hashref;
  192.                         $resellerId = $$hashref{'ResellerID'};
  193.                     }
  194.                 } else {
  195.                     &show_errors('$sth->execute() Failed', ($sth->errstr, $sql));
  196.                     $ok = 0;
  197.                     last;
  198.                 }
  199.             } else {
  200.                 &show_errors('$dbh->prepare() Failed', ($dbh->errstr));
  201.                 $ok = 0;
  202.                 last;
  203.             }
  204.         }
  205.  
  206.         my ($strdate) = "'$year-" . ($mon+1) . "-$mday $hour:$min:$sec'";
  207.         my ($sql) =<<"__EOSQL__";
  208. INSERT INTO Reg
  209. (Code, ProductID, Version, ResellerID, Name, Email, Paid, Quantity, Options, Upgrade, ExtraInfo, Date, RequestCust)
  210. SELECT
  211.     '$code',
  212.     ProductID,
  213.     $version,
  214.     $resellerId,
  215.     $customerName,
  216.     $customerEmail,
  217.     0,
  218.     $ITEM{$key}{'QUANTITY'},
  219.     $option,
  220.     $strupgrade,
  221.     $strextra,
  222.     $strdate,
  223.     $requestCust
  224. FROM Product WHERE Product.Name='$product'
  225. __EOSQL__
  226.         my($sth) = $dbh->prepare($sql);
  227.         if($sth) {
  228.             if(!$sth->execute) {
  229.                 &show_errors('$sth->execute() Failed', ($sth->errstr, $sql));
  230.                 $ok = 0;
  231.                 last;
  232.             }
  233.         } else {
  234.             &show_errors('$dbh->prepare() Failed', ($dbh->errstr));
  235.             $ok = 0;
  236.             last;
  237.         }
  238.  
  239.         if($item_upgrade) {
  240.             # If it's an upgrade, we need to delete the existing record
  241.             # We should also remove orphaned customer detail records if applicable.
  242.             my($product_id) = get_product_id($dbh, $old_product);
  243.             if($product_id > 0) {
  244.                 my($where) = 'Code=' . $dbh->quote($HEAD{'UPGRADECODE'});
  245.                 $where .= ' AND ProductID=' . $dbh->quote($product_id);
  246.                 $where .= ' AND Version=' . $dbh->quote($old_version);
  247.                 &delete_records($dbh, 'Reg', $where);
  248.             }
  249.         }
  250.     }
  251.     return $ok;
  252. }
  253.  
  254. sub insert_customer {
  255.     my($dbh) = @_;
  256.  
  257.     # List of fields to insert:
  258.     my($fields) =<<"__EOFIELDS__";
  259. Code,CustomerName,CustomerCompany,CustomerStreet,
  260. CustomerCity,CustomerState,CustomerZip,CustomerCountry,
  261. CustomerPhone,CustomerFax,CustomerEmail,CustomerNotice
  262. __EOFIELDS__
  263.  
  264.     # Values to insert:
  265.     my($values) = "'$code',";
  266.     $values .= $dbh->quote($CUSTOMER{'NAME'}) . ',';
  267.     $values .= $dbh->quote($CUSTOMER{'COMPANY'}) . ',';
  268.     $values .= $dbh->quote($CUSTOMER{'STREET'}) . ',';
  269.     $values .= $dbh->quote($CUSTOMER{'CITY'}) . ',';
  270.     $values .= $dbh->quote($CUSTOMER{'STATE'}) . ',';
  271.     $values .= $dbh->quote($CUSTOMER{'ZIP'}) . ',';
  272.     $values .= $dbh->quote($CUSTOMER{'COUNTRY'}) . ',';
  273.     $values .= $dbh->quote($CUSTOMER{'PHONE'}) . ',';
  274.     $values .= $dbh->quote($CUSTOMER{'FAX'}) . ',';
  275.     $values .= $dbh->quote($CUSTOMER{'EMAIL'}) . ',';
  276.     $values .= $dbh->quote($CUSTOMER{'NOTICE'});
  277.  
  278.     # Add delivery details if applicable:
  279.     if( ($DELIVERY{'NAME'}) && ($DELIVERY{'NAME'} ne " ") ) {
  280.         # add comma to end of $fields and to end of $values
  281.         $fields .=<<"__EOFIELDS__";
  282. ,DeliveryName,DeliveryCompany,DeliveryStreet,DeliveryCity,
  283. DeliveryState,DeliveryZip,DeliveryCountry,DeliveryPhone
  284. __EOFIELDS__
  285.         $values .= ',';
  286.         $values .= $dbh->quote($DELIVERY{'NAME'}) . ',';
  287.         $values .= $dbh->quote($DELIVERY{'COMPANY'}) . ',';
  288.         $values .= $dbh->quote($DELIVERY{'STREET'}) . ',';
  289.         $values .= $dbh->quote($DELIVERY{'CITY'}) . ',';
  290.         $values .= $dbh->quote($DELIVERY{'STATE'}) . ',';
  291.         $values .= $dbh->quote($DELIVERY{'ZIP'}) . ',';
  292.         $values .= $dbh->quote($DELIVERY{'COUNTRY'}) . ',';
  293.         $values .= $dbh->quote($DELIVERY{'PHONE'}) . '';
  294.     }
  295.  
  296.     my($sql) = "INSERT INTO Customer ($fields) VALUES ($values)";
  297.     my($ok) = 0;
  298.     my($sth) = $dbh->prepare($sql);
  299.     if($sth) {
  300.         if($sth->execute) {
  301.             $ok = 1;
  302.         } else {
  303.             &show_errors('$sth->execute() Failed', ($sth->errstr));
  304.         }
  305.     } else {
  306.         &show_errors('$dbh->prepare() Failed', ($dbh->errstr));
  307.     }
  308.     return $ok;
  309. }
  310.  
  311. sub get_product_id {
  312.     my($dbh, $name) = @_;
  313.  
  314.     my($product_id) = 0;
  315.  
  316.     my($sql) = "SELECT ProductID FROM Product WHERE Name=" . $dbh->quote($name);
  317.     my($sth) = $dbh->prepare($sql);
  318.     if($sth) {
  319.         if($sth->execute) {
  320.             my($hashref);
  321.             if($hashref = $sth->fetchrow_hashref) {
  322.                 $product_id = $$hashref{'ProductID'};
  323.             }
  324.             $sth->finish;
  325.         }
  326.     }
  327.     return($product_id);
  328. }
  329.  
  330. sub check_code {
  331.     my($dbh, $existingcode) = @_;
  332.     my($newcode) = $code;
  333.     my($rval) = 1;
  334.  
  335.     if($existingcode) {
  336.         $rval = 0;
  337.         # We have an existing code... replace it
  338.         my($sql) = "SELECT * FROM Reg WHERE Code = '$existingcode'";
  339.         my($sth) = $dbh->prepare($sql);
  340.         if($sth) {
  341.             if($sth->execute) {
  342.                 if($sth->rows > 0) {
  343.                     # The code exists...
  344.                     my($hashref) = $sth->fetchrow_hashref;
  345.                     if($$hashref{'Paid'} == 0) {
  346.                         # Not paid for, we can replace it
  347.                         # Delete whatever is already there, from both the Reg
  348.                         # table and the Customer table
  349.  
  350.                         if(&delete_records($dbh, 'Reg', "Code='$existingcode'")) {
  351.                             if(&delete_records($dbh, 'Customer', "Code='$existingcode'")) {
  352.                                 # Everything's fine...
  353.                                 $rval = 1;
  354.                                 $newcode = $existingcode;
  355.                             }
  356.                         }
  357.                     } else {
  358.                         # Paid for, don't touch it.
  359.                         $rval = 1;
  360.                     }
  361.                 } else {
  362.                     # The existing code does not already exist... ignore it
  363.                     $rval = 1;
  364.                 }
  365.                 $sth->finish;
  366.             } else {
  367.                 &show_errors('$sth->execute() Failed', ($sth->errstr));
  368.             }
  369.         } else {
  370.             &show_errors('$dbh->prepare() Failed', ($dbh->errstr));
  371.         }
  372.     }
  373.     if($rval) {
  374.         $rval = 0;
  375.         my($sql) = "SELECT * FROM Reg WHERE Code = '$newcode'";
  376.         my($sth) = $dbh->prepare($sql);
  377.         if($sth) {
  378.             if($sth->execute) {
  379.                 if($sth->rows == 0) {
  380.                     # ok, it's unique
  381.                     $rval = 1;
  382.                 } else {
  383.                     &show_errors('Non-unique Order ID', $newcode);
  384.                 }
  385.                 $sth->finish;
  386.             } else {
  387.                 &show_errors('$sth->execute() Failed', ($sth->errstr));
  388.             }
  389.         } else {
  390.             &show_errors('$dbh->prepare() Failed', ($dbh->errstr));
  391.         }
  392.     }
  393.  
  394.     $code = $newcode;
  395.     return $rval;
  396. }
  397.  
  398. sub delete_records {
  399.     my($dbh, $table, $where) = @_;
  400.     my($ok) = 0;
  401.  
  402.     if( (!$dbh) || (!$table) || (!$where) ) {
  403.         return 0;
  404.     }
  405.     my($sql) = "DELETE FROM $table WHERE $where";
  406.     my($sth) = $dbh->prepare($sql);
  407.     if($sth) {
  408.         if($sth->execute) {
  409.             $ok = 1;
  410.         } else {
  411.             &show_errors('$sth->execute() failed', ($sth->errstr));
  412.         }
  413.     } else {
  414.         &show_errors('$dbh->prepare() failed', ($dbh->errstr));
  415.     }
  416.     return $ok;
  417. }
  418.  
  419. sub get_date
  420. {
  421.     my @days   = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
  422.     my @months = ('January','February','March','April','May','June','July','August','September','October','November','December');
  423.  
  424.     ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
  425.     if ($hour < 10) { $hour = "0$hour"; }
  426.     if ($min < 10) { $min = "0$min"; }
  427.     if ($sec < 10) { $sec = "0$sec"; }
  428.  
  429.     $year += 1900;
  430.  
  431.     if($FORM{'date_format'}) {
  432.         $date = $FORM{'date_format'};
  433.         my($m_adj) = $mon + 1;
  434.         if($m_adj < 10) { $m_adj = "0$m_adj"; }
  435.         my($d_adj) = $mday;
  436.         if($d_adj < 10) { $d_adj = "0$d_adj"; }
  437.         $date =~ s/([yY]{4}?)/$year/eg;
  438.         $date =~ s/([mM]{2}?)/$m_adj/eg;
  439.         $date =~ s/([dD]{2}?)/$d_adj/eg;
  440.         $date .= ", $hour\:$min\:$sec";
  441.     } else {
  442.         $date = "$days[$wday], $months[$mon] $mday, $year, $hour\:$min\:$sec";
  443.     }
  444. }
  445.  
  446. sub send_email {
  447.  
  448.     if($FORM{'recipient'} eq "") {
  449.         print "Content-type: text/html\n\n";
  450.  
  451.         print "<html";
  452.         if ($CONFIG{'html_lang'}) {
  453.             print " lang=\"$CONFIG{'html_lang'}\"";
  454.         }
  455.         if ($CONFIG{'html_dir'}) {
  456.             print " dir=\"$CONFIG{'html_dir'}\"";
  457.         }
  458.         print ">\n";
  459.         print "<head>\n";
  460.         if ($CONFIG{'http_charset'}) {
  461.             print "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=$CONFIG{'http_charset'}\">\n";
  462.         }
  463.         print "</head>\n";
  464.  
  465.         print "<body";
  466.         &body_attributes;
  467.         print ">\n";
  468.         print "<center><img src=\"" . $external_prefix . "lockssl-on.gif\"></center><br>\n";
  469.         print "<br><br><br><br><center>\n";
  470.         print "<font size=\"+2\">$FORM{'ln_email_required'}</font><br><br>\n";
  471.         print "</center>";
  472.         print "</body>\n</html>";
  473.         die;
  474.     }
  475.  
  476.     $FORM{'order_email'} =~ s/\\n/\r\n/g;
  477.     $FORM{'order_email'} =~ s/\QCode:\E\s+[0-9a-z\-]+/Code: $code/g;
  478.  
  479.     my ($body);
  480.     if ($FORM{'clickthrough'}) {
  481.         $body    .= "Mid = " . $FORM{'clickthrough'} . " \n";
  482.     }
  483.     if ($FORM{'keywords'}) {
  484.         $body    .= "Keyword = " . $FORM{'keywords'} . " \n";
  485.     }
  486.     if ($FORM{'clickcost'}) {
  487.         $body    .= "Click-cost = " . $FORM{'clickcost'} . " \n";
  488.     }
  489.  
  490.     $to = "$FORM{'customer_email'}";
  491.     if($FORM{'email_from_field'} eq ("OFF")) {
  492.         $from = "$FORM{'customer_email'}";
  493.     }
  494.     else {
  495.         $from = "$FORM{'recipient'}";
  496.     }
  497.     $subject = "$FORM{'ln_orderfrom'} $FORM{'shopname'}";
  498.     $body .= "----------------------------------------\r\n";
  499.     $body .= "$FORM{'ln_orderfrom'} $FORM{'shopname'}\r\n";
  500.     $body .= "$FORM{'ln_submitted'}: $FORM{'customer_name'}\r\n";
  501.     $body .= "$FORM{'ln_email'}: $FORM{'customer_email'}\r\n";
  502.     $body .= "$FORM{'ln_date'}: $date\r\n";
  503.     $body .= "----------------------------------------\r\n\r\n";
  504.  
  505.     $body .= "***** Payment for this order has not been approved\n";
  506.     $body .= "***** After approving payment, please go to\n";
  507.     $body .= "***** http://www.3d3.com/regdb/ to grant download\n";
  508.     $body .= "***** access to the customer.\n\n";
  509.  
  510.     $body .= "$FORM{'order_email'}\r\n";
  511.     $body .= "\r\n----- $FORM{'ln_payment_method'} -----\r\n";
  512.  
  513.     while (($key,$value) = each %FORM) {
  514.         if ($key =~ "field_") {
  515.             ($temp = $key) =~ s/field_//g;
  516.             $body .= "$temp: $value\r\n";
  517.         }
  518.     }
  519.  
  520.     $body .= "\r\n----- $FORM{'ln_total'} -----\r\n";
  521.     $body .= "$FORM{'ln_total_weight'}: $FORM{'total_weight'}\r\n";
  522.     $body .= "$FORM{'ln_purchase_price'}: $FORM{'currency_symbol'}$FORM{'total_ex_tax'}\r\n";
  523.     $body .= "$FORM{'ln_total_tax'}: $FORM{'currency_symbol'}$FORM{'tax_value'}\r\n";
  524.     $body .= "$FORM{'ln_total_shipping'}: $FORM{'currency_symbol'}$FORM{'shipping_value'}\r\n";
  525.     $body .= "$FORM{'ln_total_inc'}: $FORM{'currency_symbol'}$FORM{'total_inc_tax'}\r\n";
  526.  
  527.     $body .= "\r\nBrowser: $ENV{'HTTP_USER_AGENT'}\r\n";
  528.     $body .= "Remote Host: $ENV{'REMOTE_HOST'}\r\n";
  529.     $body .= "Remote Address: $ENV{'REMOTE_ADDR'}\r\n";
  530.  
  531.     $date =~ s/,/-/g;
  532.     $FORM{account} =~ s/nigel's spuddly idea/$date/g;
  533.     $FORM{account} =~ s/snippy and chad/$pay/g;
  534.  
  535.     if (!&sendmail($to, $from, $subject, $body, $FORM{account}, 1)) {    # 1 = encrypt if PGP key supplied
  536.         return;
  537.     }
  538.  
  539.     # check for @ symbol before sending email
  540.     if ($FORM{'dont_email_customer'} ne "true") {
  541.         if ($FORM{'customer_email'} =~ "\@") {
  542.             $to = "$FORM{'recipient'}";
  543.             $from = "$FORM{'customer_email'}";
  544.             $subject = "$FORM{'ln_confirm'} $FORM{'shopname'}";
  545.  
  546.             $body  = "----------------------------------------\r\n";
  547.             $body .= "$FORM{'ln_confirm'} $FORM{'shopname'}\r\n";
  548.             $body .= "$FORM{'ln_submitted'}: $FORM{'customer_name'}\r\n";
  549.             $body .= "$FORM{'ln_email'}: $FORM{'customer_email'}\r\n";
  550.             $body .= "$FORM{'ln_date'}: $date\r\n";
  551.             $body .= "----------------------------------------\r\n\r\n";
  552.  
  553.             $body .= "$FORM{'order_email'}\r\n";
  554.  
  555.             $body .= "\r\n----- $FORM{'ln_total'} -----\r\n";
  556.             $body .= "$FORM{'ln_total_weight'}: $FORM{'total_weight'}\r\n";
  557.             $body .= "$FORM{'ln_purchase_price'}: $FORM{'currency_symbol'}$FORM{'total_ex_tax'}\r\n";
  558.             $body .= "$FORM{'ln_total_tax'}: $FORM{'currency_symbol'}$FORM{'tax_value'}\r\n";
  559.             $body .= "$FORM{'ln_total_shipping'}: $FORM{'currency_symbol'}$FORM{'shipping_value'}\r\n";
  560.             $body .= "$FORM{'ln_total_inc'}: $FORM{'currency_symbol'}$FORM{'total_inc_tax'}\r\n";
  561.  
  562.             $body .= "\r\nBrowser: $ENV{'HTTP_USER_AGENT'}\r\n";
  563.             $body .= "Remote Host: $ENV{'REMOTE_HOST'}\r\n";
  564.             $body .= "Remote Address: $ENV{'REMOTE_ADDR'}\r\n";
  565.             &sendmail($to, $from, $subject, $body);
  566.         }
  567.     }
  568.  
  569. }
  570.  
  571. sub send_error_email
  572. {
  573.     my($body);
  574.  
  575.     $body  = "$date\n";
  576.     $body .= "Error: $error\n";
  577.     foreach $field (@error_fields) {
  578.         $body .= "$field \n";
  579.     }
  580.     $body .="\n----- Data -----\n\n";
  581.  
  582.     $body .= "%HEAD = {\n";
  583.     foreach $key (keys %HEAD) {
  584.         $body .= "  $key = $HEAD{$key}\n";
  585.     }
  586.     $body .= "}\n";
  587.  
  588.     $body .= "%ITEM = {\n";
  589.     foreach $key (keys %ITEM) {
  590.         $body .= "  $key = {\n";
  591.         foreach $ind (keys %{ $ITEM{$key} }) {
  592.             $body .= "    $ind = $ITEM{$key}{$ind}\n";
  593.         }
  594.         $body .= "  }\n";
  595.     }
  596.     $body .= "}\n";
  597.  
  598.     $body .= "%CUSTOMER = {\n";
  599.     foreach $key (keys %CUSTOMER) {
  600.         $body .= "  $key = $CUSTOMER{$key}\n";
  601.     }
  602.     $body .= "}\n";
  603.  
  604.     $body .= "%DELIVERY = {\n";
  605.     foreach $key (keys %DELIVERY) {
  606.         $body .= "  $key = $DELIVERY{$key}\n";
  607.     }
  608.     $body .= "}\n";
  609.  
  610.     $body .= "%SHPTAX = {\n";
  611.     foreach $key (keys %SHPTAX) {
  612.         $body .= "  $key = $SHPTAX{$key}\n";
  613.     }
  614.     $body .= "}\n";
  615.  
  616.     $body .= "%TTL = {\n";
  617.     foreach $key (keys %TTL) {
  618.         $body .= "  $key = $TTL{$key}\n";
  619.     }
  620.     $body .= "}\n";
  621.  
  622.     $body .= "\n----- Param Info -----\n\n";
  623.  
  624.     # Send any specified Environment Variables to recipient.                 #
  625.     map { $body .= "$_: $FORM{$_}\n" } sort(keys(%FORM));
  626.     $body .= "\n";
  627.     map { $body .= "$_: $CONFIG{$_}\n" } sort(keys(%CONFIG));
  628.     $body .= "\n";
  629.     map { $body .= "$_: $ENV{$_}\n" } sort(keys(%ENV));
  630.     $body .= "\n";
  631.  
  632.     $body .= "\n----- UA Info -----\n\n";
  633.     $body .= "Browser: $ENV{'HTTP_USER_AGENT'}\n";
  634.     $body .= "Remote Host: $ENV{'REMOTE_HOST'}\n";
  635.     $body .= "Remote Address: $ENV{'REMOTE_ADDR'}\n";
  636.  
  637.     &sendmail($email_alert,
  638.         "\"regdb_email\" <$email_alert>",
  639.         "regdb_email error!",
  640.         $body);
  641. }
  642.  
  643. sub print_html {
  644.     print "Content-type: text/html\n\n";
  645.  
  646.     print "<html";
  647.     if ($CONFIG{'html_lang'}) {
  648.         print " lang=\"$CONFIG{'html_lang'}\"";
  649.     }
  650.     if ($CONFIG{'html_dir'}) {
  651.         print " dir=\"$CONFIG{'html_dir'}\"";
  652.     }
  653.     print ">\n";
  654.     print "<head>\n";
  655.     if ($CONFIG{'http_charset'}) {
  656.         print "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=$CONFIG{'http_charset'}\">\n";
  657.     }
  658.     print "<meta http-equiv=\"refresh\" content=\"3;url=$FORM{'thankyou_url'}\">\n";
  659.     print "</head>\n";
  660.     print "<body";
  661.     &body_attributes;
  662.     print ">\n";
  663.     print "<center><img src=\"" . $external_prefix . "lockssl-on.gif\"></center><br>\n";
  664.     print "<br><br><br><br><center>\n";
  665.     print "<font size=\"+2\">$FORM{'ln_secure_final'}.</font><br><br>\n";
  666.     print "<font size=\"-1\"><a href=\"$FORM{'thankyou_url'}\">$FORM{'ln_next'}</a></font>\n";
  667.     print "</center>";
  668.     print "</body>\n</html>";
  669. }
  670.  
  671. sub redirect {
  672.     print "Location: $FORM{'thankyou_url'}\n\n";
  673. }
  674.  
  675. sub check_referer
  676. {
  677.     my $referer_ok = 0;
  678.     if ($ENV{'HTTP_REFERER'})
  679.     {
  680.         foreach my $referer (@referers)
  681.         {
  682.             if ($ENV{'HTTP_REFERER'} =~ /$referer/i)
  683.             {
  684.                 $referer_ok = 1;
  685.                 last;
  686.             }
  687.         }
  688.     }
  689.     else
  690.     {
  691.         $referer_ok = 1;
  692.     }
  693.     return $referer_ok;
  694. }
  695.  
  696. sub check_required
  697. {
  698.     while (@ERROR) { pop(@ERROR); }
  699.     foreach $require (@required)
  700.     {
  701.         if ($require eq 'bgcolor' ||
  702.             $require eq 'background' ||
  703.             $require eq 'text_color' ||
  704.             $require eq 'link_color' ||
  705.             $require eq 'alink_color' ||
  706.             $require eq 'vlink_color') {
  707.             if (!($CONFIG{$require}) || $CONFIG{$require} eq ' ')
  708.             {
  709.                 push(@ERROR, $require);
  710.             }
  711.         }
  712.         elsif (!($FORM{$require}) || $FORM{$require} eq ' ')
  713.         {
  714.             push(@ERROR, $require);
  715.         }
  716.     }
  717.     return ($#ERROR+1 ? 0 : 1);
  718. }
  719.  
  720. #
  721. # decode_order
  722. #
  723. # takes a name-value pair order email and turns it into some hashes:
  724. # $HEAD{}
  725. # $ITEM{} including $OPTIONS[]{} for each item
  726. # $CUSTOMER{}
  727. # $DELIVERY{}
  728. # $SHIPPINGTAX{}
  729. # $TOTAL{}
  730. #
  731. sub decode_order {
  732.     my($order) = @_;
  733.     my(@lines) = split(/[\r|\n]/, $order);
  734.     my(@itemarr) = ();
  735.     foreach $line (@lines) {
  736.         chomp($line);
  737.         if($line) {
  738.             my($name, $value) = split(/=/, $line);
  739.             $value =~ s/(\r|\n)*//g;
  740.             $value = unescape($value);
  741.             if($name) {
  742.                 my($hashname, $elemname) = ($name =~ /^([A-Z]+)[_]([\w]+)/);
  743.  
  744.                 if($hashname ne "ITEM") {
  745.                     # not an item, just add it to the hash
  746.                     eval("\$$hashname\{'$elemname'\} = \$value;");
  747.  
  748.                 } else {
  749.                     # it is an item, get the number and the name
  750.                     my($itemnum, $itemname) = ($elemname =~ /^([0-9]+)[_]([\w]+)/);
  751.  
  752.                     # fix $itemnum
  753.                     $itemnum--;
  754.  
  755.                     if($itemname =~ "OPTION") {
  756.                         my($optionnum, $optionname) = ($itemname =~ /^[A-Z]+[_]([0-9]+)[_]([\w]+)/);
  757.  
  758.                         # fix $optionnum;
  759.                         $optionnum--;
  760.  
  761.                         $itemarr[$itemnum]{'OPTION'}[$optionnum]{$optionname} = $value;
  762.                     } else {
  763.                         $itemarr[$itemnum]{$itemname} = $value;
  764.                     }
  765.                 }
  766.             }
  767.         }
  768.     }
  769.  
  770.     # at this point, we have an array of items, and need to consolidate them into a hash
  771.     for $i (0 .. $#itemarr) {
  772.         for $key ( keys %{ $itemarr[$i] } ) {
  773.             if ($key =~ "OPTION") {
  774.                 for $j (0 .. $#{ $itemarr[$i]{'OPTION'} } ) {
  775.                     $ITEM{$itemarr[$i]{'ORDER_NUMBER'}}{$key} .= $itemarr[$i]{'OPTION'}[$j]{'NAME'};
  776.                     $ITEM{$itemarr[$i]{'ORDER_NUMBER'}}{$key} .= '=';
  777.                     $ITEM{$itemarr[$i]{'ORDER_NUMBER'}}{$key} .= $itemarr[$i]{'OPTION'}[$j]{'VALUE'};
  778.  
  779.                     foreach $optkey (keys %{ $itemarr[$i]{'OPTION'}[$j] }) {
  780.                         if ( ($optkey ne 'NAME') && ($optkey ne 'VALUE') ) {
  781.                             $ITEM{$itemarr[$i]{'ORDER_NUMBER'}}{$key} .= ",$optkey=";
  782.                             $ITEM{$itemarr[$i]{'ORDER_NUMBER'}}{$key} .= $itemarr[$i]{'OPTION'}[$j]{$optkey};
  783.                         }
  784.                     }
  785.  
  786.                     $ITEM{$itemarr[$i]{'ORDER_NUMBER'}}{$key} .= ';';
  787.                 }
  788.             } elsif ($key eq "QUANTITY") {
  789.                 $ITEM{$itemarr[$i]{'ORDER_NUMBER'}}{$key} += $itemarr[$i]{$key};
  790.             } else {
  791.                 $ITEM{$itemarr[$i]{'ORDER_NUMBER'}}{$key} = $itemarr[$i]{$key};
  792.             }
  793.         }
  794.     }
  795. }
  796.  
  797. sub parse_form {
  798.  
  799.     if ($ENV{'REQUEST_METHOD'} =~ 'GET') {
  800.         @pairs = split(/&/, $ENV{'QUERY_STRING'});        # Split the name-value pairs
  801.     } elsif ($ENV{'REQUEST_METHOD'} =~ 'POST') {
  802.         read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});    # Get the input
  803.         @pairs = split(/&/, $buffer);                    # Split the name-value pairs
  804.     } else {
  805.         &show_errors('request_method');
  806.     }
  807.  
  808.     foreach $pair (@pairs) {
  809.         ($name, $value) = split(/=/, $pair);            # Split pair into name and value
  810.  
  811.         $name =~ tr/+/ /;                                # un-URL-encode the name
  812.         $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
  813.         $value =~ tr/+/ /;                                # un-URL-encode the value
  814.         $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
  815.  
  816.         $value =~ s/<!--(.|\n)*-->//g;                    # remove possible SSI directives from value
  817.  
  818.         if ($name eq 'mail_encoding' ||
  819.             $name eq 'http_charset' ||
  820.             $name eq 'mail_charset' ||
  821.             $name eq 'html_lang' ||
  822.             $name eq 'html_dir' ||
  823.             $name eq 'bgcolor' ||
  824.             $name eq 'background' ||
  825.             $name eq 'text_color' ||
  826.             $name eq 'link_color' ||
  827.             $name eq 'alink_color' ||
  828.             $name eq 'vlink_color' && ($value)) {
  829.             $CONFIG{$name} = $value;
  830.         } else {
  831.             if ($FORM{$name} && ($value)) {
  832.                 $FORM{$name} = "$FORM{$name}, $value";
  833.             } elsif ($value) {
  834.                 $FORM{$name} = $value;
  835.             }
  836.         }
  837.     }
  838.     # defaults
  839.     if(!$FORM{'ln_badreferer'}) { $FORM{'ln_badreferer'} = 'Bad Referrer - Access Denied'; }
  840.     if(!$FORM{'ln_badreferer_desc'}) { $FORM{'ln_badreferer_desc'} = 'The URL of the form that is trying to use this CGI application is not in the list of valid referrers.'; }
  841.     if(!$FORM{'ln_error_missing'}) { $FORM{'ln_error_missing'} = 'Missing Fields'; }
  842.     if(!$FORM{'ln_error'}) { $FORM{'ln_error'} = 'Error'; }
  843.     if(!$FORM{'ln_orderfrom'}) { $FORM{'ln_orderfrom'} = 'Order from'; }
  844.     if(!$FORM{'ln_submitted'}) { $FORM{'ln_submitted'} = 'Submitted by'; }
  845.     if(!$FORM{'ln_email'}) { $FORM{'ln_email'} = 'email'; }
  846.     if(!$FORM{'ln_date'}) { $FORM{'ln_date'} = 'date'; }
  847.     if(!$FORM{'ln_confirm'}) { $FORM{'ln_confirm'} = 'Order confirmation from'; }
  848.     if(!$FORM{'ln_pgp_failed'}) { $FORM{'ln_pgp_failed'} = 'PGP Encryption Failed.  Check your User ID.'; }
  849.     if(!$FORM{'ln_userid_sub'}) { $FORM{'ln_userid_sub'} = 'The User ID submitted was:'; }
  850.  
  851.     # fix thankyou_url if necessary
  852.     if($FORM{'thankyou_url'} eq 'thankyou.html') { $FORM{'thankyou_url'} = $external_prefix . 'thankyou.html'; }
  853.  
  854.     # set default mail charset
  855.     if(!$CONFIG{'mail_charset'}) { $CONFIG{'mail_charset'} = $CONFIG{'http_charset'}; }
  856. }
  857.  
  858. sub show_errors {
  859.     ($error, @error_fields) = @_;
  860.  
  861.     print "Content-type: text/html\n\n";
  862.     print "<html";
  863.     if ($CONFIG{'html_lang'}) {
  864.         print " lang=\"$CONFIG{'html_lang'}\"";
  865.     }
  866.     if ($CONFIG{'html_dir'}) {
  867.         print " dir=\"$CONFIG{'html_dir'}\"";
  868.     }
  869.     print ">\n";
  870.     print "<head>\n";
  871.     if ($CONFIG{'http_charset'}) {
  872.         print "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=$CONFIG{'http_charset'}\">\n";
  873.     }
  874.     print "</head>\n";
  875.     print "<body";
  876.     &body_attributes;
  877.     print ">\n";
  878.  
  879.     if ($error eq 'bad_referer') {
  880.         print "<center>\n<h1>$FORM{'ln_badreferer'}</h1>\n</center>\n";
  881.         print "$FORM{'ln_badreferer_desc'}\n";
  882.     } elsif ($error eq 'request_method') {
  883.         print "<center>\n<h1>Invalid Request Method</h1>\n</center>\n";
  884.         print "The Request Method of the submitted form did not match\n";
  885.         print "either GET or POST.<p>\n";
  886.     } elsif ($error eq 'missing_fields') {
  887.         print "<center>\n<h1>$FORM{'ln_error_missing'}</h1>\n</center>\n";
  888.         print "$FORM{'ln_error_fields'}:<p>\n";
  889.         print "<ul>\n";
  890.         foreach $missing_field (@error_fields) {
  891.             print "<li>$missing_field\n";
  892.         }
  893.         print "</ul>\n";
  894.     } else {
  895.         print "<center>\n<h1>$FORM{'ln_error'}: $error</h1>\n</center>\n";
  896.         foreach $field (@error_fields) {
  897.             print "$field<br>";
  898.         }
  899.     }
  900.     print "</body>\n</html>\n";
  901.  
  902.     exit;
  903. }
  904.  
  905. sub body_attributes {
  906.     if ($CONFIG{'bgcolor'}) {
  907.         print " bgcolor=\"$CONFIG{'bgcolor'}\"";
  908.     }
  909.     if ($CONFIG{'background'} =~ /http\:\/\/.*\..*/) {
  910.         print " background=\"$CONFIG{'background'}\"";
  911.     }
  912.     if ($CONFIG{'link_color'}) {
  913.         print " link=\"$CONFIG{'link_color'}\"";
  914.     }
  915.     if ($CONFIG{'vlink_color'}) {
  916.         print " vlink=\"$CONFIG{'vlink_color'}\"";
  917.     }
  918.     if ($CONFIG{'alink_color'}) {
  919.         print " alink=\"$CONFIG{'alink_color'}\"";
  920.     }
  921.     if ($CONFIG{'text_color'}) {
  922.         print " text=\"$CONFIG{'text_color'}\"";
  923.     }
  924. }
  925.  
  926. sub sendmail {
  927.     my($to, $from, $subject, $body, $attach, $encrypt) = @_;
  928.  
  929.     my($encodedbody, $encodedsubject);
  930.  
  931.     # Here we PGP encrypt the body if applicable
  932.  
  933.     if($encrypt && $FORM{'pgp_user'}) {
  934.         my($pgp_user) = $FORM{'pgp_user'};
  935.         chomp($pgp_user);
  936.         $body = &pgp_encrypt($body, $pgp_user);
  937.         $attach = &pgp_encrypt($attach, $pgp_user) if defined $attach;
  938.     }
  939.  
  940.     if($CONFIG{'mail_charset'} && $CONFIG{'mail_encoding'}) {
  941.         if($encrypt && $FORM{'pgp_user'}) {
  942.             if(defined $attach) {
  943.                 $encodedbody = "Mime-Version: 1.0\r\n" .
  944.                     "Content-Type: multipart/mixed;\r\n" .
  945.                     qq'  boundary="endofmail"\r\n\r\n' .
  946.                     "This is a multi-part message in MIME format.\r\n" .
  947.                     "--endofmail\r\n" .
  948.                     "Content-Type: application/pgp\r\n" .
  949.                     "Content-Disposition: \r\n$body\r\n\r\n" .
  950.                     "--endofmail\r\n" .
  951.                     "Content-Type: application/pgp\r\n" .
  952.                     "Content-Disposition: attachment\r\n\r\n$attach\r\n\r\n" .
  953.                     "--endofmail--\r\n";
  954.             } else {
  955.                 $encodedbody = "Mime-Version: 1.0\r\n\r\n$body";
  956.             }
  957.         } else {
  958.             $encodedbody = &encode($body, $CONFIG{'mail_charset'}, $CONFIG{'mail_encoding'});
  959.         }
  960.         $encodedsubject = &encode_header($subject, $CONFIG{'mail_charset'}, $CONFIG{'mail_encoding'}, 40);
  961.     } else {
  962.         if(defined $attach) {
  963.             $encodedbody = "Mime-Version: 1.0\r\n" .
  964.                 "Content-Type: multipart/mixed;\r\n" .
  965.                 qq'  boundary="endofmail"\r\n\r\n' .
  966.                 "This is a multi-part message in MIME format.\r\n" .
  967.                 "--endofmail\r\n" .
  968.                 "Content-Type: text/plain\r\n" .
  969.                 "Content-Disposition: \r\n$body\r\n\r\n" .
  970.                 "--endofmail\r\n" .
  971.                 "Content-Type: text/plain\r\n" .
  972.                 "Content-Disposition: attachment\r\n\r\n$attach\r\n\r\n" .
  973.                 "--endofmail--\r\n";
  974.         } else {
  975.             $encodedbody = "\r\n" . $body;
  976.             $encodedsubject = $subject;
  977.         }
  978.         $encodedsubject = $subject;
  979.     }
  980.     if (lc $mailusing eq 'sendmail') {
  981.         open (MAIL, "|$mailprog -t") || &show_errors("Can't open $mailprog!");
  982.         print MAIL "To: $to\r\n";
  983.         print MAIL "From: $from\r\n";
  984.         print MAIL "Subject: $encodedsubject\r\n";
  985.         print MAIL "$encodedbody\r\n";
  986.         close MAIL;
  987.     } else {
  988.         $err = &sockets_mail($to, $from, $encodedsubject, $encodedbody);
  989.         if ($err < 1) {
  990.             &show_errors("SMTP error # $err");
  991.             return 0;
  992.         }
  993.     }
  994.     return 1;
  995. }
  996.  
  997. sub pgp_encrypt {
  998.     my($in_text, $pgp_user) = @_;
  999.     my($out_text) = '';
  1000.  
  1001.     #
  1002.     # We are piping the output of pgp to null.  stderr ends up in the web server's error log.
  1003.     # We should capture both of these, and display them to the user, if applicable
  1004.     #
  1005.     if( open(PGP, "|$pgp_cmd -r \"${pgp_user}\" $pgp_opt -o $pgp_tmp > /dev/null") ) {
  1006.         print PGP $in_text;
  1007.         close(PGP);
  1008.  
  1009.         if( open(CRYPTTMP, "<${pgp_tmp}") ) {
  1010.             while(<CRYPTTMP>) {
  1011.                 $out_text .= $_;
  1012.             }
  1013.  
  1014.             close(CRYPTTMP);
  1015.             `rm -f ${pgp_tmp}`;
  1016.         } else {
  1017.             #
  1018.             # If we get to here, it means $pgp_tmp could not be opened for reading.
  1019.             # This will usually be because pgp did not create an output file, which
  1020.             # is probably because pgp was given a non-existent user id.
  1021.             #
  1022.             # We send the email anyway, with a warning at the top.
  1023.             #
  1024.             $out_text  = "$FORM{'ln_pgp_failed'}\r\n";
  1025.             $out_text .= "$FORM{'ln_userid_sub'}\r\n";
  1026.             $out_text .= "$pgp_user\r\n\r\n";
  1027.             $out_text .= $in_text
  1028.         }
  1029.  
  1030.     } else {
  1031.         #
  1032.         # If we get to here, it means we couldn't fork $pgp_cmd.  Check the path to
  1033.         # pgp defined at the top of this file.  Also check the web server error log.
  1034.         &show_errors("Can't run PGP");
  1035.     }
  1036.  
  1037.     return($out_text);
  1038. }
  1039.  
  1040. sub sockets_mail {
  1041.     my ($to, $from, $subject, $message) = @_;
  1042.     my ($replyaddr) = $from;
  1043.     if (!$to) { return -8; }
  1044.     my ($proto, $port, $smptaddr);
  1045.     my ($AF_INET)     =  2;
  1046.     my ($SOCK_STREAM) =  1;
  1047.     $proto = (getprotobyname('tcp'))[2];
  1048.     $port  = 25;
  1049.     $smtpaddr = ($smtp_addr =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/)
  1050.                     ? pack('C4',$1,$2,$3,$4)
  1051.                     : (gethostbyname($smtp_addr))[4];
  1052.     if (!defined($smtpaddr)) { return -1; }
  1053.     if (!socket(S, $AF_INET, $SOCK_STREAM, $proto))             { return -2; }
  1054.     if (!connect(S, pack('Sna4x8', $AF_INET, $port, $smtpaddr))) { return -3; }
  1055.     select(S);
  1056.     $| = 1;
  1057.     select(STDOUT);
  1058.     $_ = <S>; if (/^[45]/) { close S; return -4; }
  1059.     print S "helo localhost\r\n";
  1060.     $_ = <S>; if (/^[45]/) { close S; return -5; }
  1061.     print S "mail from: $from\r\n";
  1062.     $_ = <S>; if (/^[45]/) { close S; return -5; }
  1063.     print S "rcpt to: $to\r\n";
  1064.     $_ = <S>; if (/^[45]/) { close S; return -6; }
  1065.     print S "data\r\n";
  1066.     $_ = <S>; if (/^[45]/) { close S; return -5; }
  1067.     print S "Content-Type: text/plain; charset=us-ascii\r\n";
  1068.     print S "To: $to\r\n";
  1069.     print S "From: $from\r\n";
  1070.     print S "Reply-to: $replyaddr\r\n" if $replyaddr;
  1071.     print S "Subject: $subject\r\n";
  1072.     print S "$message";
  1073.     print S "\r\n.\r\n";
  1074.     $_ = <S>; if (/^[45]/) { close S; return -7; }
  1075.     print S "quit\r\n";
  1076.     $_ = <S>;
  1077.     close S;
  1078.     return 1;
  1079. }
  1080.  
  1081. sub encode {
  1082.     my($body, $charset, $encoding) = @_;
  1083.     my($r);
  1084.     if( ($encoding =~ 'Quoted-Printable') || ($encoding =~ 'Base64') ) {
  1085.         $r  = "MIME-Version: 1.0\r\n";
  1086.         $r .= "Content-Type: text/plain; charset=$charset\r\n";
  1087.         $r .= "Content-transfer-encoding: $encoding\r\n\r\n";
  1088.         if($encoding =~ 'Quoted-Printable') {
  1089.             $r .= &encode_qp($body);
  1090.         } else {
  1091.             $r .= &encode_base64($body,"\n",76);
  1092.         }
  1093.     } else {
  1094.         $r = "\r\n$body";
  1095.     }
  1096.     return($r);
  1097. }
  1098.  
  1099. # Encodes a header line as either Base64 or modified Quoted-Prinable
  1100. # as per RFC 2047. $maxlen is the maximum length of the encoded part
  1101. # of the string.  If the encoded string exceeds this length, the
  1102. # remainder will be appended after CRLF SPACE
  1103. sub encode_header {
  1104.     my($text, $charset, $encoding, $maxlen) = @_;
  1105.     my($r) = "";
  1106.     my($e, $t);
  1107.     if($encoding =~ 'Quoted-Printable') {
  1108.         $e = encode_head_qp($text, $maxlen);
  1109.         $t = 'Q';
  1110.     } elsif ($encoding =~ 'Base64') {
  1111.         $e = encode_base64($text, "\n", $maxlen);
  1112.         $t = 'B';
  1113.     }
  1114.     if($e) {
  1115.         my(@el) = split(/\n/, $e);
  1116.  
  1117.         for $i (0 .. $#el) {
  1118.             $r .= "=?$charset?$t?$el[$i]?=";
  1119.             if($i != $#el) {
  1120.                 $r .= "\r\n ";
  1121.             }
  1122.         }
  1123.     } else {
  1124.         $r = $text;
  1125.     }
  1126.     return($r);
  1127. }
  1128.  
  1129. # stolen from MIME::Base64.pm and modified to include max length
  1130. sub encode_base64 ($;$;$)
  1131. {
  1132.     my $res = "";
  1133.     my $eol = $_[1];
  1134.     $eol = "\n" unless defined $eol;
  1135.     my $maxlen = $_[2];
  1136.     $maxlen = 76 unless defined $maxlen;
  1137.     pos($_[0]) = 0;                          # ensure start at the beginning
  1138.     while ($_[0] =~ /(.{1,45})/gs) {
  1139.     $res .= substr(pack('u', $1), 1);
  1140.     chop($res);
  1141.     }
  1142.     $res =~ tr|` -_|AA-Za-z0-9+/|;               # `# help emacs
  1143.     # fix padding at the end
  1144.     my $padding = (3 - length($_[0]) % 3) % 3;
  1145.     $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
  1146.     # break encoded string into lines of no more than 76 characters each
  1147.     if (length $eol) {
  1148.     $res =~ s/(.{1,$maxlen})/$1$eol/g;
  1149.     }
  1150.     $res;
  1151. }
  1152.  
  1153. # stolen from MIME::QuotedPrint.pm
  1154. sub encode_qp ($)
  1155. {
  1156.     my $res = shift;
  1157.     $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;  # rule #2,#3
  1158.     $res =~ s/([ \t]+)$/
  1159.       join('', map { sprintf("=%02X", ord($_)) }
  1160.            split('', $1)
  1161.       )/egm;                        # rule #3 (encode whitespace at eol)
  1162.  
  1163.     # rule #5 (lines must be shorter than 76 chars, but we are not allowed
  1164.     # to break =XX escapes.  This makes things complicated :-( )
  1165.     my $brokenlines = "";
  1166.     $brokenlines .= "$1=\n"
  1167.     while $res =~ s/(.*?^[^\n]{73} (?:
  1168.          [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
  1169.         |[^=\n]    (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
  1170.         |          (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
  1171.         ))//xsm;
  1172.  
  1173.     "$brokenlines$res";
  1174. }
  1175.  
  1176. # modified encode_qp for doing headers.  Includes max length
  1177. sub encode_head_qp ($;$)
  1178. {
  1179.     my $res = $_[0];
  1180.     my $maxlen = $_[1];
  1181.     $res =~ s/([^A-Za-z0-9!*+\-\/=_])/sprintf("=%02X", ord($1))/eg;
  1182.     $res =~ s/([ \t]+)$/
  1183.       join('', map { sprintf("=%02X", ord($_)) }
  1184.            split('', $1)
  1185.       )/egm;
  1186.  
  1187.     my $brokenlines = "";
  1188.     $maxlen -= 3;
  1189.     $brokenlines .= "$1\n"
  1190.     while $res =~ s/(.*?^[^\n]{$maxlen} (?:
  1191.          [^=\n]{2} (?! [^=\n]{0,1} $)
  1192.         |[^=\n]    (?! [^=\n]{0,2} $)
  1193.         |          (?! [^=\n]{0,3} $)
  1194.         ))//xsm;
  1195.  
  1196.     "$brokenlines$res";
  1197. }
  1198.